(defmacro define-tuple (class-name parents slots &optional documentation)
  "This is just to save my hands, since Netfarm class slots are mostly disjoint
and have the same printer basically.
CLASS-NAME is the name of the slot, PARENTS should be called
DIRECT-SUPERCLASSES to be accurate, SLOTS are a modified slot description list,
and DOCUMENTATION is the docstring.

SLOTS takes the form (name . plist), where plist contains:
- :READER, the reader/setter of the slot,
- :READ-ONLY, truthy if the slot should be read-only,
- :INITARG, the keyword argument,
- :INITFORM, the default value.

This generates the DEFCLASS form, and a method on PRINT-OBJECT."
  (let ((not-found (gensym "NOT-FOUND"))
        (slot-alist nil))
    (flet ((getf-or-default (list value &optional default)
             (let ((value (getf list value not-found)))
               (if (eql value not-found)
                   default
                   value))))
      `(progn
         (defclass ,class-name ,parents
           ,(loop
               for (name . arguments) in slots
               for reader-name = (or (getf arguments :reader)
                                     (intern (format nil "~a-~a" class-name name)))
               do (push (cons name reader-name) slot-alist)
               collect `(,name :initarg  ,(getf-or-default arguments :initarg
                                                           (intern (symbol-name name) 'keyword))
                               :initform ,(getf-or-default arguments :initform
                                                           `(error
                                                             ,(format nil "~a is required" name)))
                               ,(if (getf arguments :read-only)
                                    :reader :accessor)
                               ,reader-name))
           ,@(unless (null documentation)
               (list (list :documentation documentation))))
         (defmethod print-object ((object ,class-name) stream)
           (print-unreadable-object (object stream :type t :identity t)
             (pprint-logical-block (stream nil)
             ,@(loop for ((name . reader) . continuep) on (reverse slot-alist)
                     collect `(progn
                                (write-char #\: stream)
                                (write-string ,(symbol-name name) stream)
                                (write-char #\Space stream)
                                (pprint-newline :miser stream)
                                (prin1 (,reader object) stream)
                                ,@(when continuep
                                    '((write-char #\Space stream)
                                      (pprint-newline :linear stream))))))))))))