1 (defclass name () ())
    2
    3 (defclass american-name (name)
    4   ((first-name
    5      :initarg :first-name
    6      :accessor first-name)
    7     (middle-init
    8       :initarg :middle-init
    9       :accessor middle-init)
   10     (last-name
   11       :initarg :last-name
   12       :accessor last-name)))
   13
   14 (defclass international-name (name)
   15   ((given-names
   16       :initarg :given-names
   17       :accessor given-names
   18       :type (list))
   19   (family-names
   20      :initarg :family-names
   21      :accessor family-names
   22      :type (list))))
   23
   24 (defclass person ()
   25   ((name
   26      :initarg :name
   27      :documentation "Name object")
   28     (age
   29       :initarg :age
   30       :initform 0
   31       :accessor age
   32       :documentation "Person's age")
   33     (likes
   34       :initarg :likes
   35       :initform nil
   36       :accessor likes
   37       :type (list)
   38       :documentation "List of Name objects that person likes")))
   39
   40 (defun new-american (fname minit lname)
   41   "Creates a new american-name"
   42   (make-instance 'american-name :first-name fname :middle-init minit :last-name lname))
   43
   44 (defun new-international (f-names g-names)
   45   "Creates a new international-name.  Names must be of type (list)."
   46   (make-instance 'international-name :family-names f-names :given-names g-names))
   47
   48 (defmethod print-object ((object american-name) stream)
   49   (print-unreadable-object (object stream :type t)
   50     (with-slots (first-name middle-init last-name) object
   51       (format stream "~A ~A ~A" first-name middle-init last-name))))
   52
   53 (defmethod print-object ((object international-name) stream)
   54   (print-unreadable-object (object stream :type t)
   55     (with-slots (family-names given-names) object
   56       (format stream "~{~A~^ ~} ~{~A~^-~}" family-names given-names))))