From a930719a87fe8fa390ebe0a0efe6cb675ba1d1cc Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 11 Jun 2010 17:07:13 -0400
Subject: [PATCH] Add the contract information to chaperoned boxes, hashes, and
 vectors.

---
 collects/racket/contract/private/box.rkt    | 3 ++-
 collects/racket/contract/private/hash.rkt   | 3 ++-
 collects/racket/contract/private/vector.rkt | 6 ++++--
 collects/tests/racket/contract-test.rktl    | 8 ++++++++
 4 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/collects/racket/contract/private/box.rkt b/collects/racket/contract/private/box.rkt
index e19567bf58..be31b27886 100644
--- a/collects/racket/contract/private/box.rkt
+++ b/collects/racket/contract/private/box.rkt
@@ -80,7 +80,8 @@
                 (box-immutable (pos-elem-proj (unbox val)))
                 (box-wrapper val
                              (λ (b v) (pos-elem-proj v))
-                             (λ (b v) (neg-elem-proj v))))))))))
+                             (λ (b v) (neg-elem-proj v))
+                             proxy-prop:contracted ctc))))))))
 
 (define-struct (chaperone-box/c box/c) ()
   #:property prop:chaperone-contract
diff --git a/collects/racket/contract/private/hash.rkt b/collects/racket/contract/private/hash.rkt
index 2710e063ff..cf79aff76b 100644
--- a/collects/racket/contract/private/hash.rkt
+++ b/collects/racket/contract/private/hash.rkt
@@ -180,7 +180,8 @@
                  (λ (h k)
                    (neg-dom-proj k))
                  (λ (h k)
-                   (pos-dom-proj k))))))))))
+                   (pos-dom-proj k))
+                 proxy-prop:contracted ctc))))))))
 
 (define-struct (chaperone-hash/c hash/c) ()
   #:omit-define-syntaxes
diff --git a/collects/racket/contract/private/vector.rkt b/collects/racket/contract/private/vector.rkt
index 01f4ef95a3..bdfae40d28 100644
--- a/collects/racket/contract/private/vector.rkt
+++ b/collects/racket/contract/private/vector.rkt
@@ -84,7 +84,8 @@
                   (λ (vec i val)
                     (elem-pos-proj val))
                   (λ (vec i val)
-                    (elem-neg-proj val))))))))))
+                    (elem-neg-proj val))
+                  proxy-prop:contracted ctc))))))))
 
 (define-struct (chaperone-vectorof vectorof) ()
   #:property prop:chaperone-contract
@@ -237,7 +238,8 @@
                   (λ (vec i val)
                     ((vector-ref elem-pos-projs i) val))
                   (λ (vec i val)
-                    ((vector-ref elem-neg-projs i) val))))))))))
+                    ((vector-ref elem-neg-projs i) val))
+                  proxy-prop:contracted ctc))))))))
 
 (define-struct (chaperone-vector/c vector/c) ()
   #:property prop:chaperone-contract
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index e7a599cbeb..7f7f3180ae 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -9935,6 +9935,14 @@ so that propagation occurs.
     (test ctc value-contract (contract ctc (λ (x) 3) 'pos 'neg)))
   (let ([ctc (case-> (-> number? number? number?) (-> number? number?))])
     (test ctc value-contract (contract ctc (case-lambda [(x) 3] [(x y) (+ x y)]) 'pos 'neg)))
+  (let ([ctc (box/c number?)])
+    (test ctc value-contract (contract ctc (box 3) 'pos 'neg)))
+  (let ([ctc (hash/c number? number?)])
+    (test ctc value-contract (contract ctc (make-hash) 'pos 'neg)))
+  (let ([ctc (vectorof number?)])
+    (test ctc value-contract (contract ctc (vector 1 2 3) 'pos 'neg)))
+  (let ([ctc (vector/c number? number?)])
+    (test ctc value-contract (contract ctc (vector 4 5) 'pos 'neg)))
   
 ;                             
 ;