- (setf (find-classoid name) lclass
- (classoid-name lclass) name)))))
-
-(defun set-class-type-translation (class name)
- (let ((classoid (find-classoid name nil)))
- (etypecase classoid
- (null)
- (built-in-classoid
- (let ((translation (built-in-classoid-translation classoid)))
- (cond
- (translation
- (aver (ctype-p translation))
- (setf (info :type :translator class)
- (lambda (spec) (declare (ignore spec)) translation)))
- (t
- (setf (info :type :translator class)
- (lambda (spec) (declare (ignore spec)) classoid))))))
- (classoid
- (setf (info :type :translator class)
- (lambda (spec) (declare (ignore spec)) classoid))))))
+ (when (and name (symbolp name) (eq name (classoid-name classoid)))
+ (setf (find-classoid name) classoid))))))
+
+(defun set-class-type-translation (class classoid)
+ (when (not (typep classoid 'classoid))
+ (setq classoid (find-classoid classoid nil)))
+ (etypecase classoid
+ (null)
+ (built-in-classoid
+ (let ((translation (built-in-classoid-translation classoid)))
+ (cond
+ (translation
+ (aver (ctype-p translation))
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) translation)))
+ (t
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) classoid))))))
+ (classoid
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) classoid)))))