From a4087991e3ff1650b2c6d73c0f3d9b37f737a30a Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Mon, 17 May 2010 13:11:10 -0400
Subject: [PATCH] Convert vectorof/vector-immutableof to the new regime.

Also add old-style vectorof to mzlib/contract.

original commit: 3028f2d1424123d076a95572a7564b8fb069a86e
---
 collects/mzlib/contract.rkt                 |  2 --
 collects/mzlib/private/contract-mutable.rkt | 24 ++++++++++++++++++++-
 2 files changed, 23 insertions(+), 3 deletions(-)

diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt
index 68296b6..1ced3d7 100644
--- a/collects/mzlib/contract.rkt
+++ b/collects/mzlib/contract.rkt
@@ -37,7 +37,6 @@
 ;;
 
 (require racket/contract/private/base
-         racket/contract/private/vector
          racket/contract/private/misc
          racket/contract/private/provide
          racket/contract/private/guts
@@ -52,7 +51,6 @@
              contract-struct)
  
  (all-from-out racket/contract/private/base)
- (all-from-out racket/contract/private/vector)
  (all-from-out racket/contract/private/provide)
  (except-out (all-from-out racket/contract/private/misc)
              check-between/c
diff --git a/collects/mzlib/private/contract-mutable.rkt b/collects/mzlib/private/contract-mutable.rkt
index 69f4617..0e09536 100644
--- a/collects/mzlib/private/contract-mutable.rkt
+++ b/collects/mzlib/private/contract-mutable.rkt
@@ -1,10 +1,13 @@
 #lang racket/base
 
 (require (only-in racket/contract/private/box box-immutable/c)
+         (only-in racket/contract/private/vector
+                  vector/c vector-immutableof vector-immutable/c)
          racket/contract/private/blame
          racket/contract/private/guts)
 
-(provide box/c box-immutable/c)
+(provide box/c box-immutable/c
+         vector/c vectorof vector-immutableof vector-immutable/c)
 
 (define/subexpression-pos-prop (box/c ctc)
   (let ([ctc (coerce-flat-contract 'box/c ctc)])
@@ -22,3 +25,22 @@
              (raise-blame-error blame val "not a box"))
            (proj (unbox val))
            val))))))
+
+(define/subexpression-pos-prop (vectorof ctc)
+  (let ([ctc (coerce-flat-contract 'vectorof ctc)])
+    (make-flat-contract
+     #:name (build-compound-type-name 'vectorof ctc)
+     #:first-order
+     (λ (val)
+       (and (vector? val)
+            (for/and ([v (in-vector val)])
+              (contract-first-order-passes? ctc v))))
+     #:projection
+     (λ (blame)
+       (λ (val)
+         (let ([proj ((contract-projection ctc) blame)])
+           (unless (vector? val)
+             (raise-blame-error blame val "not a vector"))
+           (for ([v (in-vector val)])
+             (proj v))
+           val))))))