diff --git a/collects/unstable/gui/ppict.rkt b/collects/unstable/gui/ppict.rkt
new file mode 100644
index 0000000000..bd58ef926e
--- /dev/null
+++ b/collects/unstable/gui/ppict.rkt
@@ -0,0 +1,246 @@
+#lang racket/base
+(require racket/list
+         racket/contract
+         slideshow/pict)
+
+#|
+TODO
+
+- need a way to express "dependent" additions, when need to find a
+  pict within a ppict, eg for lines, balloons, etc.
+
+- [lcr]bl alignments... not sure about [lcr]tl
+
+- make ppict-do macro, move functionality from pslide to ppict-do
+  eg require #:go for placers, use #:next to return multiple picts
+|#
+
+;; ============================================================
+;; Progressive Picts
+
+#|
+A ppict contains a pict and a placer (or #f).
+A placer = (placer (pict (listof (U pict real #f)) -> ppict))
+In a placer function's arguments:
+  a number means to change the separation spacing
+  a #f is just ignored
+  FIXME: clarify, for following or including current gap?
+|#
+(struct ppict pict (placer))
+(struct placer (fun))
+
+(define (mk-ppict p placer)
+  (ppict (pict-draw p)
+         (pict-width p)
+         (pict-height p)
+         (pict-ascent p)
+         (pict-descent p)
+         (list (make-child p 0 0 1 1))
+         #f
+         (pict-last p)
+         placer))
+
+(define (ppict-pict dp)
+  (child-pict (car (pict-children dp))))
+
+;; ----
+
+;; ppict-do : pict (U pict real #f placer) ... -> pict
+(define (ppict-do base . elems)
+  (define (loop elems rchunks)
+    (cond [(and (pair? elems) (placer? (car elems)))
+           (loop (cdr elems) (cons (car elems) rchunks))]
+          [(and (pair? elems))
+           (loop* (cdr elems) rchunks (list (car elems)))]
+          [(null? elems)
+           (reverse rchunks)]))
+  (define (loop* elems rchunks rchunk)
+    (cond [(and (pair? elems) (placer? (car elems)))
+           (loop elems (cons (reverse rchunk) rchunks))]
+          [(and (pair? elems))
+           (loop* (cdr elems) rchunks (cons (car elems) rchunk))]
+          [(null? elems)
+           (loop elems (cons (reverse rchunk) rchunks))]))
+  (let ([chunks (loop elems null)])
+    (for/fold ([acc base]) ([chunk (in-list chunks)])
+      (cond [(placer? chunk)
+             (ppict-go acc chunk)]
+            [(list? chunk)
+             (apply ppict-add acc chunk)]))))
+
+;; ppict-add : ppict (U pict real #f) ... -> ppict
+(define (ppict-add dp . picts)
+  (let ([pl (ppict-placer dp)])
+    ((placer-fun pl) (ppict-pict dp) picts)))
+
+;; ppict-go : pict placer -> ppict
+(define (ppict-go dp pl)
+  (cond [(ppict? dp)
+         (mk-ppict (ppict-pict dp) pl)]
+        [(pict? dp)
+         (mk-ppict dp pl)]))
+
+;; ----
+
+;; row, column indexes are 0-based
+(define (grid cols rows col row [align 'cc]
+              #:compose [composer (align->vcomposer align)]
+              #:sep [sep 0])
+  (define halign (align->h align))
+  (define valign (align->v align))
+  (define refxfrac (/ (+ col (align->frac halign)) cols))
+  (define refyfrac (/ (+ row (align->frac valign)) rows))
+  (coord refxfrac refyfrac align #:compose composer #:sep sep))
+
+(define (coord refxfrac refyfrac [align 'cc]
+               #:compose [composer (align->vcomposer align)]
+               #:sep [sep 0]
+               #:internal:skip [skip #f])
+  (define halign (align->h align))
+  (define valign (align->v align))
+  (placer
+   (lambda (scene picts)
+     (define scene-w (pict-width scene))
+     (define scene-h (pict-height scene))
+     (define refx (* scene-w refxfrac))
+     (define refy (* scene-h refyfrac))
+     (define-values (newpict newsep)
+       (apply-composer composer sep (cons skip picts)))
+     (define newpict-w (pict-width newpict))
+     (define newpict-h (pict-height newpict))
+     (define localrefx (* newpict-w (align->frac halign)))
+     (define localrefy (* newpict-h (align->frac valign)))
+     (define newscene
+       (lt-superimpose scene (inset newpict (- refx localrefx) (- refy localrefy) 0 0)))
+     (let ([result-pict (refocus newscene scene)])
+       (cond [(and (eq? valign 't) (eq? composer (align->vcomposer align)))
+              ;; ie, going top-down and composer is the natural composer for this align
+              (mk-ppict result-pict
+                        (coord refxfrac refyfrac align
+                               #:compose composer
+                               #:sep newsep
+                               #:internal:skip (blank 0 newpict-h)))]
+             [(and (eq? halign 'l) (eq? composer (align->hcomposer align)))
+              (mk-ppict result-pict
+                        (coord refxfrac refyfrac align
+                               #:compose composer
+                               #:sep newsep
+                               #:internal:skip (blank newpict-w 0)))]
+             [else result-pict])))))
+
+;; ----
+
+;; apply-composer : composer real (listof (U #f pict real)) -> (values pict real)
+;; Returns composed pict and last given separator num in elems (or init-sep, if none)
+(define (apply-composer composer init-sep elems)
+  (define (start-loop sep elems)
+    (cond [(and (pair? elems) (real? (car elems)))
+           (start-loop (car elems) (cdr elems))]
+          [(and (pair? elems) (pict? (car elems)))
+           (join-loop (car elems) sep (cdr elems))]
+          [(null? elems)
+           (blank 0)]))
+  (define (join-loop base sep elems)
+    (cond [(and (pair? elems) (real? (car elems)))
+           (join-loop base (car elems) (cdr elems))]
+          [(and (pair? elems) (pict? (car elems)))
+           (join-loop (composer sep base (car elems))
+                      sep
+                      (cdr elems))]
+          [(null? elems) base]))
+  (values (start-loop init-sep (filter values elems))
+          (last (cons init-sep (filter real? elems)))))
+
+;; ----
+
+(define (align->frac align)
+  (case align
+    ((t l)   0)
+    ((c)   1/2)
+    ((b r)   1)))
+
+(define (align->h align)
+  (case align
+    ((lt lc lb) 'l)
+    ((ct cc cb) 'c)
+    ((rt rc rb) 'r)))
+
+(define (align->v align)
+  (case align
+    ((lt ct rt) 't)
+    ((lc cc rc) 'c)
+    ((lb cb rb) 'r)))
+
+(define (align->vcomposer align)
+  (case align
+    ((lt lc lb) vl-append)
+    ((ct cc cb) vc-append)
+    ((rt rc rb) vr-append)))
+
+(define (align->hcomposer align)
+  (case align
+    ((lt ct rt) ht-append)
+    ((lc cc rc) hc-append)
+    ((lb cb rb) hb-append)))
+
+;; ==== Some examples ====
+
+#|
+(slide
+ (let* ([dp (colorize (rectangle 200 200) "gray")]
+        [dp (ppict-go dp (grid 2 2 1 0 'ct))]
+        [dp (ppict-add dp (circle 20) (circle 20) (circle 20))])
+   (vc-append gap-size
+              (shframe dp)
+              (shframe
+               (ppict-add dp (colorize (circle 20) "red"))))))
+
+(slide
+ (let* ([dp (colorize (rectangle 200 200) "gray")]
+        [dp (ppict-go dp (grid 2 2 0 0 'lb #:compose hbl-append))]
+        [dp (ppict-add dp (circle 20) (circle 20) (circle 20))])
+   (vc-append gap-size
+              (shframe dp)
+              (shframe
+               (ppict-add dp (colorize (circle 20) "red"))))))
+|#
+
+;; ============================================================
+;; Exports
+
+(define align/c
+  (or/c 'lt 'ct 'rt
+        'lc 'cc 'rc
+        'lb 'cb 'rb))
+
+(provide ppict?
+         placer?)
+
+(provide/contract
+ [ppict-do
+  (->* (pict?)
+       ()
+       #:rest (listof (or/c pict? real? #f placer?))
+       pict?)]
+ [ppict-go
+  (-> pict? placer? ppict?)]
+ [ppict-add
+  (->* (ppict?)
+       ()
+       #:rest (listof (or/c pict? real? #f))
+       pict?)]
+ [ppict-placer
+  (-> ppict? placer?)]
+ [placer
+  (-> any/c boolean?)]
+ [coord
+  (->* (real? real?)
+       (align/c
+        #:compose procedure?)
+       placer?)]
+ [grid
+  (->* (exact-positive-integer? exact-positive-integer?
+        exact-nonnegative-integer? exact-nonnegative-integer?)
+       (align/c
+        #:compose procedure?)
+       placer?)])
diff --git a/collects/unstable/gui/pslide.rkt b/collects/unstable/gui/pslide.rkt
new file mode 100644
index 0000000000..341392a85a
--- /dev/null
+++ b/collects/unstable/gui/pslide.rkt
@@ -0,0 +1,139 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     syntax/parse
+                     syntax/parse/experimental/contract)
+         racket/list
+         racket/contract
+         racket/gui/base
+         slideshow/base
+         slideshow/pict
+         "ppict.rkt")
+
+;; ============================================================
+;; Progressive Slides
+
+(struct p:elem (value))
+(struct p:out ())
+(struct p:go (placer))
+
+(define pslide-base-pict
+  (make-parameter (lambda () (blank client-w client-h))))
+
+(define pslide-default-placer
+  (make-parameter (coord 1/2 1/2 'cc)))
+
+;; pslide* : (U p:elem p:out p:go) ... -> void
+(define (pslide* . elems)
+  (let ([gochunks
+         (get-gochunks (p:go (pslide-default-placer))
+                       (append elems (list (p:out))))])
+    (do-gochunks ((pslide-base-pict)) gochunks)
+    (void)))
+
+;; ----
+
+;; A gochunk is (cons p:go (listof (U p:elem p:next)))
+
+;; get-gochunks : p:go (listof (U p:elem p:out p:go)) -> (listof gochunk)
+(define (get-gochunks init-go elems)
+  (define (loop init-go elems)
+    (cond [(and (pair? elems) (p:go? (car elems)))
+           (loop (car elems) (cdr elems))]
+          [(pair? elems)
+           (let-values ([(chunk tail) (split-until p:go? elems)])
+             (cons (cons init-go chunk)
+                   (if (pair? tail)
+                       (loop (car tail) (cdr tail))
+                       null)))]
+          [(null? elems) null]))
+  (loop init-go elems))
+
+(define (do-gochunks base gochunks)
+  (for/fold ([base base]) ([gochunk (in-list gochunks)])
+    (let* ([placer (p:go-placer (car gochunk))]
+           [chunk (cdr gochunk)]
+           [base (ppict-go base placer)])
+      (do-chunk base chunk))))
+
+;; do-chunk : ppict (listof (U p:elem p:out)) -> ppict
+(define (do-chunk base chunk)
+  (let ([elem-chunks
+         ;; (listof (listof pict?))
+         ;;   length is N+1, where N is number of (p:out) in chunk
+         ;;   ghosted before visible
+         (let elab ([chunk chunk])
+           (cond [(and (pair? chunk) (p:out? (car chunk)))
+                  (let ([elab-rest (elab (cdr chunk))])
+                    (cons (map ghost* (car elab-rest))
+                          elab-rest))]
+                 [(and (pair? chunk) (p:elem? (car chunk)))
+                  (for/list ([elem-chunk (in-list (elab (cdr chunk)))])
+                    (cons (p:elem-value (car chunk))
+                          elem-chunk))]
+                 [(null? chunk)
+                  (list null)]))])
+    (let out-loop ([chunks elem-chunks])
+      (cond [(null? (cdr chunks))
+             (apply ppict-add base (car chunks))]
+            [else
+             (slide (apply ppict-add base (car chunks)))
+             (out-loop (cdr chunks))]))))
+
+;; ----
+
+(define (split-until stop? elems)
+  (let loop ([elems elems] [rprefix null])
+    (cond [(and (pair? elems) (stop? (car elems)))
+           (values (reverse rprefix) elems)]
+          [(pair? elems)
+           (loop (cdr elems) (cons (car elems) rprefix))]
+          [(null? elems)
+           (values (reverse rprefix) null)])))
+
+(define (ghost* x)
+  (if (pict? x) (ghost x) x))
+
+;; ----
+
+(define-syntax (pslide stx)
+
+  (define-splicing-syntax-class fragment
+    #:description "pslide fragment"
+    (pattern (~seq #:go pl)
+             #:declare pl (expr/c #'placer? #:name "argument to #:go")
+             #:with code #'(p:go pl.c))
+    (pattern (~seq #:next)
+             #:with code #'(p:out))
+    (pattern (~seq e)
+             #:declare e (expr/c #'(or/c pict? real? #f) #:name "element")
+             #:with code #'(p:elem e.c)))
+
+  (syntax-parse stx
+    [(_ p:fragment ...)
+     #'(pslide* p.code ...)]))
+
+;; ---- Example ----
+
+#|
+(pslide* (p:elem (t "this is the time to remember"))
+         (p:out)
+         (p:elem (t "because it will not last forever"))
+         (p:out)
+         (p:go (coord 1 0 'rt))
+         (p:elem 50)
+         (p:elem #f)
+         (p:elem (t "this is the time"))
+         (p:elem (t "because it will")))
+|#
+
+
+;; ============================================================
+;; Exports
+
+(provide/contract
+ [pslide-base-pict
+  (parameter/c (-> pict?))]
+ [pslide-default-placer
+  (parameter/c placer?)])
+
+(provide pslide)
diff --git a/collects/unstable/scribblings/gui.scrbl b/collects/unstable/scribblings/gui.scrbl
index 06adcde828..8255ab1d30 100644
--- a/collects/unstable/scribblings/gui.scrbl
+++ b/collects/unstable/scribblings/gui.scrbl
@@ -11,3 +11,4 @@
 @include-section["gui/notify.scrbl"]
 @include-section["gui/prefs.scrbl"]
 @include-section["gui/slideshow.scrbl"]
+@include-section["gui/pslide.scrbl"]
diff --git a/collects/unstable/scribblings/gui/pslide.scrbl b/collects/unstable/scribblings/gui/pslide.scrbl
new file mode 100644
index 0000000000..fa384c7717
--- /dev/null
+++ b/collects/unstable/scribblings/gui/pslide.scrbl
@@ -0,0 +1,271 @@
+#lang scribble/doc
+@(require scribble/base
+          scribble/manual
+          scribble/eval
+          "../utils.rkt"
+          (for-label racket/base
+                     slideshow
+                     unstable/gui/ppict
+                     unstable/gui/pslide))
+
+@title[#:tag "ppict"]{Progressive Picts and Slides}
+@unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]]
+
+@(define the-eval (make-base-eval))
+@(the-eval '(require slideshow/pict unstable/gui/ppict))
+
+@section[#:tag "ppicts"]{Progressive Picts}
+
+@defmodule[unstable/gui/ppict]
+
+A @deftech{progressive pict} or ``ppict'' is a kind of @racket[pict]
+that has an associated ``pict placer,'' which generally represents a
+position and alignment. New picts can be placed on the progressive
+pict by calling @racket[ppict-add], and the placer can be updated by
+calling @racket[ppict-go]. The @racket[ppict-do] function provides a
+compact notation for sequences of those two operations.
+
+@examples[#:eval the-eval
+(define base
+  (ppict-do (colorize (rectangle 200 200) "gray")
+            (coord 1/2 1/2 'cc)
+            (colorize (hline 200 1) "gray")
+            (coord 1/2 1/2 'cc)
+            (colorize (vline 1 200) "gray")))
+base
+(define circles-down-1
+  (ppict-do base
+            (grid 2 2 1 0 'ct)
+            10
+            (circle 20)
+            (circle 20)
+            30
+            (circle 20)))
+circles-down-1
+(define circles-down-2
+  (ppict-do circles-down-1
+            (colorize (circle 20) "red")
+            40
+            (colorize (circle 20) "red")))
+(code:line (inset circles-down-2 20) (code:comment "draws outside its bounding box"))
+(inset (clip circles-down-2) 20)
+]
+
+
+@defproc[(ppict? [x any/c]) boolean?]{
+
+Returns @racket[#t] if @racket[x] is a @tech{progressive pict},
+@racket[#f] otherwise.
+}
+
+@defproc[(ppict-do [p pict?]
+                   [cmd (or/c pict? real? #f placer?)] ...)
+         pict?]{
+
+Starting with @racket[p], applies @racket[ppict-go] for every
+@racket[cmd] that is a placer and @racket[ppict-add] for every
+sequence of @racket[cmd]s that are picts, real numbers, and
+@racket[#f].
+
+A spacing change, represented by a real number, only affects added
+picts up until the next placer is installed; when a placer is
+installed, the spacing is reset to @racket[0].
+
+For example, the following code
+@racketblock[
+(ppict-do (colorize (rectangle 200 200) "gray")
+          (coord 1/2 1/2 'cc)
+          (colorize (hline 200 1) "gray")
+          (coord 1/2 1/2 'cc)
+          (colorize (vline 1 200) "gray"))
+]
+is equivalent to
+@racketblock[
+(let ([pp (colorize (rectangle 200 200) "gray")]
+      [pp (ppict-go pp (coord 1/2 1/2 'cc))]
+      [pp (ppict-add pp (colorize (hline 200 1) "gray"))]
+      [pp (ppict-go pp (coord 1/2 1/2 'cc))]
+      [pp (ppict-add pp (colorize (vline 1 200) "gray"))])
+  pp)
+]
+}
+
+@defproc[(ppict-go [p pict?] [pl placer?]) ppict?]{
+
+Creates a @tech{progressive pict} with the given base pict @racket[p]
+and the placer @racket[pl].
+}
+
+@defproc[(ppict-add [pp ppict?]
+                    [elem (or/c pict? real? #f)] ...)
+         pict?]{
+
+Creates a new pict by adding each @racket[elem] pict on top of
+@racket[pp] according to @racket[pp]'s placer. The result pict may or
+may not be a @tech{progressive pict}, depending on the placer used.
+
+An @racket[elem] that is a real number changes the spacing for
+subsequent additions. A @racket[elem] that is @racket[#f] is
+discarded; it is permitted as a convenience for conditionally
+including sub-picts. Note that @racket[#f] is not equivalent to
+@racket[(blank 0)], since the latter will cause spacing to be added
+around it.
+}
+
+@defproc[(placer? [x any/c]) boolean?]{
+
+Returns @racket[#t] if @racket[x] is a placer, @racket[#f] otherwise.
+}
+
+@defproc[(coord [relx real?] [rely real?]
+                [align (or/c 'lt 'ct 'rt 'lc 'cc 'rc 'lb 'cb 'rb) 'cc]
+                [#:compose composer procedure? #, @elem{computed from @racket[align]}])
+         placer?]{
+
+Returns a placer that places picts according to a reference point
+determined by @racket[relx] and @racket[rely], which are interpeted as
+fractions of the width and height of the base @tech{progressive
+pict}. That is, @racket[0], @racket[0] is the top left corner of the
+base's bounding box, and @racket[1], @racket[1] is the bottom right.
+
+Additions are aligned according to @racket[align], a symbol whose name
+consists of a horizontal alignment character followed by a vertical
+alignment character. If @racket[align] is @racket['lt], the pict is
+placed so that its left-top corner is at the reference point; if
+@racket[align] is @racket['rc], the pict is placed so that the center
+of its bounding box's right edge coincides with the reference point.
+
+By default, if there are multiple picts to be placed, they are
+verictally appended, aligned according to the horizontal component of
+@racket[align]. For example, if @racket[align] is @racket['cc], the
+default @racket[composer] is @racket[vc-append]; for @racket['lt], the
+default @racket[composer] is @racket[vl-append]. The spacing is
+initially @racket[0].
+
+@;{
+The result of @racket[ppict-add] using a @racket[coord] placer is
+another progressive pict only if 
+}
+
+@examples[#:eval the-eval
+(ppict-do base 
+          (coord 1/3 3/4 'cc)
+          (circle 20))
+(ppict-do base
+          (coord 1 0 'rt)
+          50 (code:comment "change spacing")
+          (text "abc")
+          (text "12345")
+          0  (code:comment "and again")
+          (text "ok done"))
+(ppict-do base
+          (coord 0 0 'lt #:compose ht-append)
+          (circle 10)
+          (circle 20)
+          (circle 30))
+]
+}
+
+@defproc[(grid [cols exact-positive-integer?]
+               [rows exact-positive-integer?]
+               [col exact-nonnegative-integer?]
+               [row exact-nonnegative-integer?]
+               [align (or/c 'lt 'ct 'rt 'lc 'cc 'rc 'lb 'cb 'rb) 'cc]
+               [#:compose composer procedure? #, @elem{computed from @racket[align]}])
+         placer?]{
+
+Returns a placer that places picts according to a position in a
+virtual grid. The @racket[row] and @racket[col] indexes are numbered
+starting at @racket[0].
+
+Uses of @racket[grid] can be translated into uses of @racket[coord],
+but the translation depends on the alignment. For example,
+@racket[(grid 2 2 0 0 'lt)] is equivalent to @racket[(coord 0 0 'lt)],
+but @racket[(grid 2 2 0 0 'rt)] is equivalent to @racket[(coord 1/2 0 'rt)].
+
+@examples[#:eval the-eval
+(define none-for-me-thanks
+  (ppict-do base
+            (grid 2 2 0 0 'lt)
+            (text "You do not like")
+            (colorize (text "green eggs and ham?") "darkgreen")))
+none-for-me-thanks
+(ppict-do none-for-me-thanks
+          (grid 2 2 1 0 'rb)
+          (colorize (text "I do not like them,") "red")
+          (text "Sam-I-am."))
+]
+}
+
+
+@section[#:tag "pslide"]{Progressive Slides}
+
+@defmodule[unstable/gui/pslide]
+
+@defform/subs[(pslide pslide-fragment ...)
+              ([pslide-fragment (code:line #:go placer-expr)
+                                (code:line #:next)
+                                (code:line elem-expr)])
+              #:contracts ([placer-expr placer?]
+                           [elem-expr (or/c pict? real? #f)])]{
+
+Constructs a slide using the @tech{progressive pict} mechanism. A
+@racket[#:go] directive updates the current placer; a @racket[#:next]
+directive causes a slide to be emitted with the contents thus far (but
+whose alignment takes into account contents yet to be added); and
+other elements have the same meaning as in @racket[ppict-add].
+
+Remember to include @racket[gap-size] after updating the current
+placer if you want @racket[slide]-like spacing.
+
+@examples[#:eval the-eval
+(eval:alts (pslide #:go (coord 0 0 'lt)
+                   (t "You do not like")
+                   (colorize (t "green eggs and ham?") "darkgreen")
+                   #:next
+                   #:go (coord 1 1 'rb)
+                   (colorize (t "I do not like them,") "red")
+                   (t "Sam-I-am."))
+           (let* ([slide1
+                   (ppict-do (colorize (filled-rectangle 200 150) "white")
+                             (coord 1/20 1/20 'lt) ;; for margins
+                             (text "You do not like")
+                             (colorize (text "green eggs and ham?")
+                             "darkgreen"))]
+                  [slide2
+                   (ppict-do slide1
+                             (coord 19/20 19/20 'rb) ;; for margins
+                             (colorize (text "I do not like them,") "red")
+                             (text "Sam-I-am."))]
+                  [slides
+                   (inset
+                    (vl-append -5 
+                               (colorize (text "slides" '(bold . roman)) "white")
+                               (inset (hc-append 20 slide1 slide2) 15))
+                    5)])
+             (cc-superimpose
+              (colorize (filled-rectangle (pict-width slides) (pict-height slides))
+                        "darkgray")
+              slides)))
+]
+}
+
+@defparam[pslide-base-pict make-base-pict (-> pict)]{
+
+Controls the initial pict used by @racket[pslide]. The default value
+is
+@racketblock[
+(lambda () (blank client-w client-h))
+]
+}
+
+@defparam[pslide-default-placer placer placer?]{
+
+Controls the initial placer used by @racket[pslide]. The default value
+is
+@racketblock[
+(coord 1/2 1/2 'cc)
+]
+}
+
+@(close-eval the-eval)