--- old-alexandria/hash-tables.lisp	2008-03-10 15:40:48.000000000 +0100
+++ new-alexandria/hash-tables.lisp	2008-03-10 15:40:48.000000000 +0100
@@ -1,18 +1,23 @@
 (in-package :alexandria)
 
-(defun copy-hash-table (table &key
-                        (test (hash-table-test table))
-                        (size (hash-table-size table))
-                        (rehash-size (hash-table-size table))
-                        (rehash-threshold (hash-table-rehash-threshold table)))
-  "Returns a shallow copy of hash table TABLE, with the same keys and values
+(defun copy-hash-table (table &key copy-fn test size
+                                   rehash-size rehash-threshold)
+  "Returns a copy of hash table TABLE, with the same keys and values
 as the TABLE. The copy has the same properties as the original, unless
-overridden by the keyword arguments."
+overridden by the keyword arguments.
+
+The values are copied by calling COPY-FN which defaults to CL:IDENTITY;
+thus a shallow copy is returned by default."
+  (setf copy-fn (or copy-fn 'identity))
+  (setf test (or test (hash-table-test table)))
+  (setf size (or size (hash-table-size table)))
+  (setf rehash-size (or rehash-size (hash-table-size table)))
+  (setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table)))
   (let ((copy (make-hash-table :test test :size size
                                :rehash-size rehash-size
                                :rehash-threshold rehash-threshold)))
     (maphash (lambda (k v)
-               (setf (gethash k copy) v))
+               (setf (gethash k copy) (funcall copy-fn v)))
              table)
     copy))
 

--- old-alexandria/tests.lisp	2008-03-10 15:40:48.000000000 +0100
+++ new-alexandria/tests.lisp	2008-03-10 15:40:48.000000000 +0100
@@ -156,6 +156,24 @@
               (gethash "FOO" equalp-copy))))
   (123 2 t nil t t nil t))
 
+(deftest copy-hash-table.2
+    (let ((ht (make-hash-table))
+          (list (list :list (vector :A :B :C))))
+      (setf (gethash 'list ht) list)
+      (let* ((shallow-copy (copy-hash-table ht))
+	     (deep1-copy (copy-hash-table ht :copy-fn 'copy-list))
+	     (list         (gethash 'list ht))
+	     (shallow-list (gethash 'list shallow-copy))
+	     (deep1-list   (gethash 'list deep1-copy)))
+        (list (eq ht shallow-copy)
+	      (eq ht deep1-copy)
+	      (eq list shallow-list)
+	      (eq list deep1-list)	             ; outer list was copied.
+	      (eq (second list) (second shallow-list))
+	      (eq (second list) (second deep1-list)) ; inner vector wasn't copied.
+	      )))
+  (nil nil t nil t t))
+
 (deftest maphash-keys.1
     (let ((keys nil)
           (table (make-hash-table)))