(defclass message-class (standard-class) ())

(defmethod print-object ((object message-class) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (prin1 (class-name object) stream)))

(defmethod c2mop:validate-superclass ((c message-class) (s standard-class)) t)

(defmethod c2mop:validate-superclass ((c standard-class) (s message-class)) t)

(defvar *message-classes* (make-hash-table :test #'equal))

(defun find-message-class (name)
  (assert (and (listp name) (every #'symbolp name)) (name)
          "NAME must be a list of symbols, not ~S." name)
  (values (gethash name *message-classes*)))

(defun (setf find-message-class) (new-value name)
  (assert (and (listp name) (every #'symbolp name)) (name)
          "NAME must be a list of symbols, not ~S." name)
  (assert (typep new-value '(or class null)) (new-value)
          "NEW-VALUE must be a class metaobject or NIL, not ~S." new-value)
  (if new-value
      (setf (gethash name *message-classes*) new-value)
      (remhash name *message-classes*)))

(defmacro define-message-class
    (name direct-superclasses direct-slots &rest options)
  (let ((gensym (gensym)))
    `(unwind-protect
          (progn (setf (find-class ',gensym) (find-message-class ',name))
                 (defclass ,gensym ,direct-superclasses ,direct-slots
                   (:metaclass message-class)
                   ,@options)
                 (setf (find-message-class ',name) (find-class ',gensym))
                 (find-class ',gensym))
       (let ((class (find-class ',gensym)))
         (setf (find-class ',gensym) nil)
         (setf (class-name class) ',name)))))






CL-USER> (define-message-class (foo bar) () ())
#<MESSAGE-CLASS (FOO BAR) {1003B8EA63}>
CL-USER> (find-message-class '(foo bar))
#<MESSAGE-CLASS (FOO BAR) {1003B8EA63}>
CL-USER> (make-instance *)
#<#<MESSAGE-CLASS (FOO BAR) {1003B8EA63}> {1003C24793}>