(defun dump-clim-application
    (packages pathname command-tables
     &rest args &key (initializer #'identity) force &allow-other-keys)
  (let ((p (mapcar #'find-package packages))
	(force-specializers '()))
    (labels
	((%extract-hash-table (hash-table)
	   (let ((alist '()))
	     (maphash (lambda (k v)
			(when (or (member (symbol-package k) p)
				  (and command-tables
				       (gethash k command-tables)))
			  (when (typep v 'class)
			    (pushnew v force)
			    (pushnew (sb-kernel:find-classoid (class-name v))
				     force))
			  (let ((specializer
				 (gethash k
					  sb-pcl::*eql-specializer-table*)))
			    (when specializer
			      (pushnew specializer force-specializers)))
			  (push (cons k v) alist)))
		      hash-table)
	     alist))
	 (extract-hash-table (sym)
	   (cons sym (%extract-hash-table (symbol-value sym))))
	 (%restore-hash-table (table alist)
	   (loop for (k . v) in alist do
		 (setf (gethash k table) v)
		 (when (typep v 'class)
		   (setf (find-class (class-name v)) v))))
	 (restore-hash-table (x)
	   (%restore-hash-table (symbol-value (car x)) (cdr x)))
	 ;; climacs-specific hack to find anonymous command tables
	 ;; fixme: is this still needed?
	 (extract-climacs-tables (sym)
	   (let ((hash-table (symbol-value sym))
		 (anonymous-command-tables '())
		 (alist '()))
	     (maphash (lambda (k v)
			(when (member (symbol-package k) p)
			  (dolist (mi (slot-value v 'climi::keystroke-items))
			    (pushnew (clim:command-menu-item-value
				      (clim:menu-item-value mi))
				     anonymous-command-tables))))
		      hash-table)
	     (dolist (name anonymous-command-tables)
	       (push (cons name (gethash name hash-table)) alist))
	     (cons sym alist)))
	 (restore-ptrans-data (x)
	   (loop for (name alist1 alist2) in x do
		 (let ((table (gethash name climi::*command-tables*)))
		   (when table
		     (let ((ttable (climi::presentation-translators table)))
		       (%restore-hash-table
			(climi::translators ttable)
			alist1)
		       (%restore-hash-table
			(climi::simple-type-translators ttable)
			alist2)))))
	   (incf climi::*current-translator-cache-generation*))
	 (restore-command-data (x)
	   (loop for (name . alist) in x do
		 (let ((table (gethash name climi::*command-tables*)))
		   (when table
		     (%restore-hash-table (climi::commands table) alist))))
	   (incf climi::*current-translator-cache-generation*)))
      (let ((data
             (list
              (extract-hash-table 'climi::*command-tables*)
              (extract-climacs-tables 'climi::*command-tables*)
              (extract-hash-table 'climi::*command-parser-table*)
              (extract-hash-table 'climi::*presentation-type-table*)
              (extract-hash-table 'climi::*presentation-gf-table*)
              (extract-hash-table 'climi::*presentation-type-abbreviations*)))
	    (ptrans-data '())
	    (command-data '())
	    (forced-classes
	     (remove-if-not (lambda (x) (typep x 'class)) force)))
	(maphash (lambda (name table)
		   (when (typep table 'clim:standard-command-table)
		     (let ((ttable (climi::presentation-translators table)))
		       (push (list name
				   (%extract-hash-table
				    (climi::translators ttable))
				   (%extract-hash-table
				    (climi::simple-type-translators ttable)))
			     ptrans-data))
		     (push (cons name
				 (%extract-hash-table (climi::commands table)))
			   command-data)))
		 climi::*command-tables*)
        (apply #'sb-heapdump:dump-packages
               packages
               pathname
               :force (cons #'dump-clim-application force)
	       :force-specializers (append force-specializers forced-classes)
               :initializer (lambda (x)
                              (mapc #'restore-hash-table data)
			      (restore-ptrans-data ptrans-data)
			      (restore-command-data command-data)
                              (funcall initializer x))
               ;; CLIM wants the +foo-ink+s to be unique objects.
               :customizer (lambda (object)
                             (dolist (var '(climi::*unsupplied-argument-marker*
                                            climi::*numeric-argument-marker*
                                            clim:+foreground-ink+
                                            clim:+foreground-ink+
                                            clim:+background-ink+
                                            clim:+flipping-ink+)
                                       t)
                               (when (eq object (symbol-value var))
                                 (return (values :fixup var)))))
               :load-time-customizer (lambda (sym ignore)
                                       ignore
                                       (symbol-value sym))
               args)))))